home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / oobr / br-lib.el < prev    next >
Encoding:
Text File  |  1995-08-26  |  38.3 KB  |  1,086 lines
  1. ;;!emacs
  2. ;;
  3. ;; FILE:         br-lib.el
  4. ;; SUMMARY:      OO-Browser support functions.
  5. ;; USAGE:        GNU Emacs Lisp Library
  6. ;; KEYWORDS:     oop, tools
  7. ;;
  8. ;; AUTHOR:       Bob Weiner
  9. ;; ORG:          Motorola Inc.
  10. ;;
  11. ;; ORIG-DATE:    22-Mar-90
  12. ;; LAST-MOD:     24-Aug-95 at 17:11:03 by Bob Weiner
  13. ;;
  14. ;; Copyright (C) 1990-1995  Free Software Foundation, Inc.
  15. ;; See the file BR-COPY for license information.
  16. ;;
  17. ;; This file is part of the OO-Browser.
  18.  
  19. ;;; ************************************************************************
  20. ;;; Other required Elisp libraries
  21. ;;; ************************************************************************
  22.  
  23. (mapcar 'require '(br-env br-ftr br-compl set))
  24.  
  25. ;;; ************************************************************************
  26. ;;; Public variables
  27. ;;; ************************************************************************
  28.  
  29. (defvar br-null-path "<none>"
  30.   "Pathname associated with OO-Browser entities which have no source file.
  31. That is, virtual entities, such as categories.")
  32.  
  33. ;;; ************************************************************************
  34. ;;; General public functions
  35. ;;; ************************************************************************
  36.  
  37. (defun br-buffer-replace (regexp to-str)
  38.   "In current buffer, replace all occurrences of REGEXP with TO-STR."
  39.   (goto-char (point-min))
  40.   (while (re-search-forward regexp nil t)
  41.     (replace-match to-str 'fixedcase nil)
  42.     (backward-char 1)))
  43.  
  44. (defun br-delete-space (string)
  45.   "Delete any leading and trailing space from STRING and return the STRING. "
  46.   (if (string-match "\\`\\s *\\(\\(.\\|\n\\)*\\S \\)\\s *\\'" string)
  47.       (setq string (substring string (match-beginning 1)
  48.                   (match-end 1)))
  49.     string))
  50.  
  51. (defun br-first-match (regexp list)
  52.   "Return non-nil if REGEXP matches to an element of LIST.
  53. All elements of LIST must be strings.
  54. The value returned is the first matched element."
  55.   (while (and list (not (string-match regexp (car list))))
  56.     (setq list (cdr list)))
  57.   (car list))
  58.  
  59. (defun br-filename-head (path)
  60.   (setq path (file-name-nondirectory path))
  61.   (if (string-match "\\(.+\\)\\." path)
  62.       (substring path 0 (match-end 1))
  63.     path))
  64.  
  65. (defun br-duplicate-and-unique-strings (sorted-strings)
  66.   "Return SORTED-STRINGS list with a list of duplicate entries consed onto the front of the list."
  67.   (let ((elt1) (elt2) (lst sorted-strings)
  68.     (count 0) (repeat) (duplicates))
  69.     (while (setq elt1 (car lst) elt2 (car (cdr lst)))
  70.       (cond ((not (string-equal elt1 elt2))
  71.          (setq lst (cdr lst)))
  72.         ((equal elt1 repeat)
  73.         ;; Already recorded this duplicate.
  74.          (setcdr lst (cdr (cdr lst))))
  75.         (t ;; new duplicate
  76.          (setq count (1+ count)
  77.            duplicates (cons elt1 duplicates)
  78.            repeat elt1)
  79.          (setcdr lst (cdr (cdr lst))))))
  80.     (cons (sort duplicates 'string-lessp) sorted-strings)))
  81.  
  82. (defun br-set-of-strings (sorted-strings &optional count)
  83.   "Return SORTED-STRINGS list with any duplicate entries removed.
  84. Optional COUNT conses number of duplicates on to front of list before return."
  85.   (and count (setq count 0))
  86.   (let ((elt1) (elt2) (lst sorted-strings)
  87.     (test (if count
  88.           (function
  89.             (lambda (a b) (if (string-equal a b)
  90.                       (setq count (1+ count)))))
  91.         (function (lambda (a b) (string-equal a b))))))
  92.     (while (setq elt1 (car lst) elt2 (car (cdr lst)))
  93.       (if (funcall test elt1 elt2)
  94.       (setcdr lst (cdr (cdr lst)))
  95.     (setq lst (cdr lst)))))
  96.   (if count (cons count sorted-strings) sorted-strings))
  97.  
  98. (defun br-member-sorted-strings (elt list)
  99.   "Return non-nil if ELT is an element of LIST.  Comparison done with 'string-equal'.
  100. All ELTs must be strings and the list must be sorted in ascending order.
  101. The value returned is actually the tail of LIST whose car is ELT."
  102.   (while (and list (not (string-equal (car list) elt)))
  103.     (setq list (and (string-lessp (car list) elt)
  104.             (cdr list))))
  105.   list)
  106.  
  107. (defun br-pathname-head (path)
  108.   (if (string-match "\\(.+\\)\\." path)
  109.       (substring path 0 (match-end 1))
  110.     path))
  111.  
  112. (defun br-quote-match (match-num)
  113.   "Quote special symbols in last matched expression MATCH-NUM."
  114.   (br-regexp-quote (buffer-substring (match-beginning match-num)
  115.                      (match-end match-num))))
  116.  
  117. (defun br-rassoc (elt list)
  118.   "Return non-nil if ELT is the cdr of an element of LIST.
  119. Comparison done with 'equal'.  The value is actually the tail of LIST
  120. starting at the element whose cdr is ELT."
  121.   (while (and list (not (equal (cdr (car list)) elt)))
  122.     (setq list (cdr list)))
  123.   list)
  124.  
  125. (defun br-regexp-quote (obj)
  126.   "If OBJ is a string, quote and return it for use in a regular expression."
  127.   ;; Don't use (stringp obj) here since we want to signal an error if some
  128.   ;; caller ever passes in a non-nil, non-string object, to aid in debugging.
  129.   (if obj (regexp-quote obj)))
  130.  
  131. (defun br-relative-path (filename &optional directory)
  132.   "Convert FILENAME to be relative to DIRECTORY or default-directory.
  133. The shorter of the absolute and relative paths is returned."
  134.   (let ((relative-path (file-relative-name filename directory)))
  135.     (if (< (length relative-path) (length filename))
  136.     relative-path
  137.       filename)))
  138.  
  139. (defmacro br-set-cons (set elt)
  140.   "Add to SET element ELT.  Returns nil iff ELT is already in SET.
  141. Uses 'equal' for comparison."
  142.   (` (if (br-member (, elt) (, set))
  143.      nil
  144.        (setq (, set) (cons (, elt) (, set))))))
  145.  
  146.  
  147. (defun br-wind-line-at-point ()
  148.   "Return window relative line number that point is on."
  149.   (max 0 (1- (- (count-lines 1 (1+ (point)))
  150.         (count-lines 1 (window-start))))))
  151.  
  152. ;;; ************************************************************************
  153. ;;; Browser public functions
  154. ;;; ************************************************************************
  155.  
  156. (defun br-add-class (class-name &optional class-path lib-table-p save-file)
  157.   "Add or replace CLASS-NAME in current Environment.
  158.   Find class source in optional CLASS-PATH.  Interactively or when optional
  159. CLASS-PATH is nil, defaults to current buffer file as CLASS-PATH.  If
  160. optional LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
  161. System Environment.  If optional SAVE-FILE is t, the Environment is then
  162. stored to filename given by 'br-env-file'.  If SAVE-FILE is non-nil and
  163. not t, its string value is used as the file to which to save the Environment.
  164. Does not update children lookup table."
  165.   (interactive
  166.     (list (read-string "Class name to add: ")
  167.       (read-file-name (concat "Class file name"
  168.                   (if buffer-file-name
  169.                       " (default <current file>)")
  170.                   ": ")
  171.               nil buffer-file-name t)
  172.       (y-or-n-p "Add to Library, rather than System tables? ")
  173.       (y-or-n-p
  174.         (concat "Save tables after addition to " br-env-file "? "))))
  175.   ;; 
  176.   ;; Pseudo code:
  177.   ;; 
  178.   ;;    If class-name is in table
  179.   ;;       If function called interactively
  180.   ;;          Query whether should overwrite class-name in tables
  181.   ;;          If yes
  182.   ;;             Replace entry
  183.   ;;          else
  184.   ;;             Don't add class; do nothing
  185.   ;;          end
  186.   ;;       else
  187.   ;;          Store class in all necessary tables
  188.   ;;       end
  189.   ;;    else
  190.   ;;       Store class under key in all necessary tables
  191.   ;;    end
  192.   ;;
  193.   (or class-path (setq class-path buffer-file-name)
  194.       (error "No class pathname specified."))
  195.   (if (or (string-equal class-name "")
  196.       (not (or (equal class-path br-null-path)
  197.            (file-exists-p class-path))))
  198.       (error (format "Invalid class specified, '%s', in: %s" class-name class-path)))
  199.   ;; Is class already in Environment?
  200.   (if (hash-key-p class-name (br-get-htable
  201.                    (if lib-table-p "lib-parents" "sys-parents")))
  202.       (if (interactive-p)
  203.       (if (y-or-n-p (format "Overwrite existing '%s' entry? " class-name))
  204.           (br-real-add-class lib-table-p class-name class-path 'replace)
  205.         (setq save-file nil))
  206.     (br-real-add-class lib-table-p class-name class-path))
  207.     (br-real-add-class lib-table-p class-name class-path))
  208.   (cond ((eq save-file nil))
  209.     ((eq save-file t) (br-env-save))
  210.     ((br-env-save save-file))))
  211.  
  212. (defun br-build-lib-htable ()
  213.   "Build Library dependent Environment."
  214.   (interactive)
  215.   (cond    ((and (interactive-p)
  216.            (not (y-or-n-p "Rebuild Library Environment? ")))
  217.      nil)
  218.     (t
  219.      (message "Building Library Environment...")
  220.      (sit-for 2)
  221.      (br-real-build-alists br-lib-search-dirs)
  222.      (setq br-lib-paths-htable (hash-make br-paths-alist)
  223.            br-lib-parents-htable (hash-make br-parents-alist))
  224.      (run-hooks 'br-after-build-lib-hook)
  225.      (br-env-set-htables)
  226.      (br-build-children-htable)
  227.      ;; Set prev-search-dirs so table rebuilds are not triggered.
  228.      (setq br-lib-prev-search-dirs br-lib-search-dirs)
  229.      (if (interactive-p) (br-env-save))
  230.      (message "Building Library Environment...Done")
  231.      t)))
  232.  
  233. (defun br-build-sys-htable ()
  234.   "Build System dependent class Environment."
  235.   (interactive)
  236.   (cond    ((and (interactive-p)
  237.           (not (y-or-n-p "Rebuild System Environment? ")))
  238.      nil)
  239.     (t
  240.      (message "Building System Environment...")
  241.      (sit-for 2)
  242.      (br-real-build-alists br-sys-search-dirs)
  243.      (setq br-sys-paths-htable (hash-make br-paths-alist)
  244.            br-sys-parents-htable (hash-make br-parents-alist))
  245.      (run-hooks 'br-after-build-sys-hook)
  246.      (br-env-set-htables)
  247.      (br-build-children-htable)
  248.      ;; Set prev-search-dirs so table rebuilds are not triggered.
  249.      (setq br-sys-prev-search-dirs br-sys-search-dirs)
  250.      (if (interactive-p) (br-env-save))
  251.      (message "Building System Environment...Done")
  252.      t)))
  253.  
  254. (defun br-class-in-table-p (class-name)
  255.   "Return t iff CLASS-NAME is found in current Environment."
  256.   (interactive (list (br-complete-class-name)))
  257.   (if class-name (hash-key-p class-name (br-get-parents-htable))))
  258.  
  259. (defun br-class-path (class-name &optional insert)
  260.   "Return full path, if any, to CLASS-NAME.
  261. With optional prefix argument INSERT non-nil, insert path at point.
  262. Only the first matching class is returned, so each CLASS-NAME should be
  263. unique. Set 'br-lib/sys-search-dirs' properly before use."
  264.   (interactive (list (br-complete-class-name)))
  265.   (setq class-name (if class-name (br-set-case class-name)))
  266.   (let* ((class-path)
  267.      (class-htable (br-get-paths-htable)))
  268.     (hash-map
  269.       (function (lambda (val-key-cons)
  270.           (and (null class-path)
  271.                (br-member-sorted-strings class-name (car val-key-cons))
  272.                (setq class-path (br-select-path val-key-cons nil)))))
  273.       class-htable)
  274.     (if (equal class-path br-null-path)
  275.     (setq class-path nil))
  276.     (and (interactive-p) (setq insert current-prefix-arg))
  277.     (if (and insert class-path)
  278.     (insert class-path)
  279.       (if (interactive-p)
  280.       (message
  281.        (or class-path
  282.            (format
  283.         "(OO-Browser): No '%s' class found in 'br-lib/sys-search-dirs'."
  284.         class-name)))))
  285.     class-path))
  286.  
  287. (defun br-find-class (&optional class-name view-only other-win)
  288.   "Display file of class text matching CLASS-NAME in VIEW-ONLY mode if non-nil.
  289. Return t if class is successfully displayed, nil otherwise.  Can also
  290. signal an error when called interactively."
  291.   (interactive)
  292.   (and (interactive-p) (setq view-only current-prefix-arg))
  293.   (let ((class-path)
  294.     (info (equal br-lang-prefix "info-"))
  295.     (err))
  296.     (setq class-name
  297.       (or class-name (br-complete-class-name))
  298.       class-path (br-class-path class-name))
  299.     (cond 
  300.      (info (info-find-nd class-path class-name (not view-only)))
  301.      (class-path
  302.       (if (file-readable-p class-path)
  303.       (progn (if view-only 
  304.              (funcall br-view-file-function class-path other-win)
  305.            (funcall br-edit-file-function class-path other-win)
  306.            ;; Handle case of already existing buffer in
  307.            ;; read only mode.
  308.            (and buffer-read-only
  309.             (file-writable-p class-path)
  310.             (progn (setq buffer-read-only nil)
  311.                    ;; Force mode-line redisplay
  312.                    (set-buffer-modified-p
  313.                 (buffer-modified-p)))))
  314.          (br-major-mode)
  315.          (let ((opoint (point))
  316.                (start)
  317.                (pmin (point-min))
  318.                (pmax (point-max))
  319.                (class-def (br-class-definition-regexp class-name)))
  320.            (widen)
  321.            (goto-char (point-min))
  322.            (if br-narrow-view-to-class
  323.                ;; Display file narrowed to definition of
  324.                ;; 'class-name'.
  325.                (if (re-search-forward class-def nil t)
  326.                ;; Narrow display to this class
  327.                (progn (narrow-to-region
  328.                    (progn (setq opoint
  329.                         (goto-char
  330.                          (match-beginning 0)))
  331.                       (br-to-comments-begin)
  332.                       (setq start (point))
  333.                       (goto-char opoint)
  334.                       start)
  335.                    (progn (br-to-class-end)
  336.                       (point)))
  337.                   (goto-char (point-min)))
  338.              (goto-char opoint)
  339.              (narrow-to-region pmin pmax)
  340.              (setq err (format "(OO-Browser):  No '%s' in %s" class-name
  341.                        class-path))
  342.              )
  343.              (if (re-search-forward class-def nil t)
  344.              (progn (setq opoint (goto-char (match-beginning 0)))
  345.                 (br-to-comments-begin)
  346.                 (recenter 0))
  347.                (goto-char opoint)
  348.                (narrow-to-region pmin pmax)
  349.                (setq err (format "(OO-Browser):  No '%s' in %s" class-name
  350.                     class-path))
  351.                )))
  352.          (setq class-path t))
  353.     (setq err (format "(OO-Browser):  '%s' - src file not found or not readable, %s"
  354.               class-name class-path)
  355.           class-path nil)
  356.     )
  357.       (if (interactive-p)
  358.       (setq err
  359.         (format "(OO-Browser):  No '%s' class defined in Environment."
  360.             class-name))
  361.     )))
  362.     (if err (error err))
  363.     class-path))
  364.  
  365. (defun br-major-mode ()
  366.   "Invoke language-specific major mode on current buffer if not already set."
  367.   (or (eq major-mode (symbol-function 'br-lang-mode))
  368.       (br-lang-mode)))
  369.  
  370. (defun br-show-children (class-name)
  371.   "Return children of CLASS-NAME from current Environment."
  372.   (interactive (list (br-complete-class-name t)))
  373.   (and class-name
  374.        (br-get-children class-name)))
  375.  
  376. (defun br-show-parents (class-name)
  377.   "Return parents of CLASS-NAME from Environment or scan of current buffer's source."
  378.   (interactive (list (br-complete-class-name t)))
  379.   (and class-name
  380.        (if (br-class-in-table-p class-name)
  381.        (br-get-parents class-name)
  382.      (and buffer-file-name (br-get-parents-from-source buffer-file-name
  383.                                class-name)))))
  384.  
  385. (defun br-undefined-classes ()
  386.   "Return a list of the classes referenced but not defined within the current Environment."
  387.   (let ((classes (hash-get br-null-path (br-get-paths-htable))))
  388.     (delq nil (mapcar (function (lambda (class)
  389.                   ;; Remove default classes
  390.                   (if (/= (aref class 0) ?\[)
  391.                       class)))
  392.               classes))))
  393.  
  394. ;;; ************************************************************************
  395. ;;; Private functions
  396. ;;; ************************************************************************
  397.  
  398. (defun br-add-to-paths-htable (class-name paths-key htable)
  399.   "Add CLASS-NAME under PATHS-KEY in paths lookup HTABLE, keeping the classes sorted."
  400.   (let ((other-classes (hash-get paths-key htable)))
  401.     (if (and other-classes (br-member-sorted-strings class-name other-classes))
  402.     nil
  403.       (hash-add (sort (cons class-name other-classes) 'string-lessp)
  404.         paths-key htable))))
  405.  
  406. (defun br-build-lib-parents-htable ()
  407.   (interactive)
  408.   (if (not br-lib-search-dirs)
  409.       nil
  410.     (message "Building Library parent...")
  411.     (sit-for 2)
  412.     (setq br-lib-parents-htable
  413.       (hash-make
  414.         (if br-lib-paths-htable
  415.         (br-real-build-parents-alist br-lib-paths-htable)
  416.           (br-real-build-alists br-lib-search-dirs)
  417.           br-parents-alist)))
  418.     (if (interactive-p) (br-env-save))
  419.     (message "Building Library parent...Done")))
  420.  
  421. (defun br-build-lib-paths-htable ()
  422.   (interactive)
  423.   (if (not br-lib-search-dirs)
  424.       nil
  425.     (message "Building Library paths...")
  426.     (sit-for 2)
  427.     (br-real-build-alists br-lib-search-dirs)
  428.     (setq br-lib-paths-htable (hash-make br-paths-alist))
  429.     (if (interactive-p) (br-env-save))
  430.     (message "Building Library paths...Done")))
  431.  
  432. (defun br-build-sys-parents-htable ()
  433.   (interactive)
  434.   (if (not br-sys-search-dirs)
  435.       nil
  436.     (message "Building System parents...")
  437.     (sit-for 2)
  438.     (setq br-sys-parents-htable
  439.       (hash-make
  440.         (if br-sys-paths-htable
  441.         (br-real-build-parents-alist br-sys-paths-htable)
  442.           (br-real-build-alists br-sys-search-dirs)
  443.           br-parents-alist)))
  444.     (if (interactive-p) (br-env-save))
  445.     (message "Building System parents...Done")))
  446.  
  447. (defun br-build-sys-paths-htable ()
  448.   (interactive)
  449.   (if (not br-sys-search-dirs)
  450.       nil
  451.     (message "Building System paths...")
  452.     (sit-for 2)
  453.     (br-real-build-alists br-sys-search-dirs)
  454.     (setq br-sys-paths-htable (hash-make br-paths-alist))
  455.     (if (interactive-p) (br-env-save))
  456.     (message "Building System paths...Done")))
  457.  
  458. (defun br-build-children-htable ()
  459.   (interactive)
  460.   (setq br-children-htable (br-real-build-children-htable))
  461.   (if (interactive-p) (br-env-save)))
  462.  
  463. (defun br-build-parents-htable ()
  464.   (interactive)
  465.   (br-build-sys-parents-htable)
  466.   (br-build-lib-parents-htable)
  467.   ;; Make System entries override Library entries which they duplicate, since
  468.   ;; this is generally more desireable than merging the two.
  469.   (let ((hash-merge-values-function (function (lambda (val1 val2) val1))))
  470.     (setq br-parents-htable (hash-merge br-sys-parents-htable
  471.                     br-lib-parents-htable)))
  472.   (if (interactive-p) (br-env-save)))
  473.  
  474. (defun br-build-paths-htable ()
  475.   (interactive)
  476.   (br-build-sys-paths-htable)
  477.   (br-build-lib-paths-htable)
  478.   (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable))
  479.   (if (interactive-p) (br-env-save)))
  480.  
  481. (defun br-class-defined-p (class)
  482.   "Return path for CLASS if defined in current Environment.
  483. Otherwise, display error and return nil."
  484.   (or (br-class-path class)
  485.       (progn
  486.     (beep)
  487.     (message
  488.      (if (br-class-in-table-p class)
  489.          (format "(OO-Browser):  Class '%s' referenced but not defined in Environment."
  490.              class)
  491.        (format "(OO-Browser):  Class '%s' not defined in Environment."
  492.            class)))
  493.     nil)))
  494.  
  495. (defun br-check-for-class (cl &optional other-win)
  496.   "Try to display class CL.
  497. Display message and return nil if unsucessful."
  498.   (if (br-class-in-table-p cl)
  499.       (or (br-find-class cl nil other-win)
  500.       (progn
  501.         (beep)
  502.         (message
  503.          (format "(OO-Browser):  Class '%s' referenced but not defined in Environment."
  504.              cl))
  505.         t))))
  506.  
  507. (defun br-get-children (class-name)
  508.   "Return list of children of CLASS-NAME from child lookup table.
  509. Those which directly inherit from CLASS-NAME."
  510.   (setq class-name (and class-name (br-set-case class-name)))
  511.   (br-set-of-strings (hash-get class-name (br-get-children-htable))))
  512.  
  513. (defun br-get-parents (class-name)
  514.   "Return list of parents of CLASS-NAME from parent lookup table.
  515. Those from which CLASS-NAME directly inherits."
  516.   (setq class-name (and class-name (br-set-case class-name)))
  517.   (br-set-of-strings (hash-get class-name (br-get-parents-htable))))
  518.  
  519. (defun br-get-children-htable ()
  520.   "Loads or builds 'br-children-htable' if necessary and returns value."
  521.   (br-get-htable "children"))
  522.  
  523. (defun br-get-paths-htable ()
  524.   "Loads or builds 'br-paths-htable' if necessary and returns value."
  525.   (br-get-htable "paths"))
  526.  
  527. (defun br-get-parents-htable ()
  528.   "Loads or builds 'br-parents-htable' if necessary and returns value."
  529.   (br-get-htable "parents"))
  530.  
  531. (defun br-get-children-from-parents-htable (class-name)
  532.   "Return list of children of CLASS-NAME.
  533. Those that directly inherit from CLASS-NAME.  Use parent lookup table to
  534. compute children."
  535.   (setq class-name (and class-name (br-set-case class-name)))
  536.   (delq nil (hash-map (function (lambda (cns)
  537.                   (if (and (consp cns)
  538.                        (br-member class-name (car cns)))
  539.                       (cdr cns))))
  540.               (br-get-parents-htable))))
  541.  
  542. (defun br-get-htable (htable-type)
  543.   "Return hash table corresponding to string, HTABLE-TYPE.  When necessary,
  544. load the hash table from a file or build it."
  545.   (let* ((htable-symbol (intern-soft (concat "br-" htable-type "-htable")))
  546.      (htable-specific (if (string-match "sys\\|lib" htable-type)
  547.                   (substring htable-type (match-beginning 0)
  548.                      (match-end 0))))
  549.      changed-types non-matched-types)
  550.     (if (equal htable-type "children")
  551.     nil
  552.       (if (and (or (not htable-specific) (equal htable-specific "lib"))
  553.            (or (null (symbol-value htable-symbol))
  554.            (not (equal br-lib-prev-search-dirs br-lib-search-dirs))))
  555.       (setq changed-types '("lib")))
  556.       (if (and (or (not htable-specific) (equal htable-specific "sys"))
  557.            (or (null (symbol-value htable-symbol))
  558.            (not (equal br-sys-prev-search-dirs br-sys-search-dirs))))
  559.       (setq changed-types (cons "sys" changed-types))))
  560.     (if (and (or br-lib-search-dirs br-sys-search-dirs)
  561.          (or changed-types (null (symbol-value htable-symbol)))
  562.          (not (boundp 'br-loaded)))
  563.     ;;
  564.     ;; Then need to load or rebuild htable.
  565.     ;;
  566.     (progn (if (and br-env-file
  567.             (file-exists-p br-env-file))
  568.            ;;
  569.            ;; Try to load from file.
  570.            ;;
  571.            (progn (setq non-matched-types
  572.                 (br-env-load-matching-htables changed-types))
  573.               (if non-matched-types
  574.                   (setq changed-types
  575.                     (delq nil (mapcar
  576.                            (function
  577.                         (lambda (type)
  578.                           (if (br-member type
  579.                                  changed-types)
  580.                               type)))
  581.                            non-matched-types)))
  582.                 (and changed-types (br-env-set-htables))
  583.                 (setq changed-types nil)
  584.                 (cond (htable-specific)
  585.                   ((equal htable-type "children")
  586.                    (progn (goto-char (point-min))
  587.                       (setq br-children-htable
  588.                         (cdr (br-env-file-sym-val
  589.                               "br-children-htable")))))
  590.                   ((let ((suffix
  591.                       (concat "-" htable-type "-htable"))
  592.                      (hash-merge-values-function
  593.                       'hash-merge-values))
  594.                      ;; Make System entries override
  595.                      ;; Library entries which they
  596.                      ;; duplicate, if this is the parents
  597.                      ;; htable.
  598.                      (if (equal htable-type "parents")
  599.                      (setq hash-merge-values-function
  600.                            (function
  601.                         (lambda (val1 val2) val1))))
  602.                      (set htable-symbol
  603.                       (hash-merge
  604.                        (symbol-value
  605.                         (intern-soft
  606.                          (concat "br-sys" suffix)))
  607.                        (symbol-value
  608.                         (intern-soft
  609.                          (concat
  610.                           "br-lib" suffix)))
  611.                        ))))))))
  612.            ;; Rebuild any lists that need to be changed.
  613.            (mapcar
  614.         (function
  615.          (lambda (type-str)
  616.            (let ((suffix (concat "-" htable-type "-htable")))
  617.              (funcall (intern-soft
  618.                    (concat "br-build-" type-str suffix)))
  619.              (and htable-specific
  620.               ;; Make System entries override Library entries
  621.               ;; which they duplicate, if this is the parents
  622.               ;; htable.
  623.               (let ((hash-merge-values-function
  624.                  'hash-merge-values))
  625.                 (if (equal htable-type "parents")
  626.                 (setq hash-merge-values-function
  627.                       (function (lambda (val1 val2) val1))))
  628.                 (set htable-symbol
  629.                  (hash-merge (symbol-value
  630.                           (intern-soft
  631.                            (concat "br-sys" suffix)))
  632.                          (symbol-value
  633.                           (intern-soft
  634.                            (concat "br-lib" suffix)))
  635.                          )))))))
  636.         changed-types)
  637.            (if (and changed-types br-env-file)
  638.            (br-env-save))
  639.            (let ((buf (get-file-buffer br-env-file)))
  640.          (and buf (kill-buffer buf)))
  641.            ))
  642.     ;; Return non-nil hash table.
  643.     (if (null (symbol-value htable-symbol))
  644.     (set htable-symbol (hash-make 0))
  645.       (symbol-value htable-symbol))))
  646.  
  647. (defun br-get-top-class-list (htable-type-str)
  648.     "Returns unordered list of top-level classes.
  649. Those that do not explicitly inherit from any other classes.  Obtains classes
  650. from list denoted by HTABLE-TYPE-STR whose values may be:
  651. \"parents\", \"sys-parents\", or \"lib-parents\"."
  652.     (delq nil (hash-map (function
  653.               (lambda (cns)
  654.                 (and (null (car cns)) (cdr cns))))
  655.             (br-get-htable htable-type-str))))
  656.  
  657. (defun br-get-top-classes ()
  658.   "Returns lexicographically ordered list of top-level classes.
  659. Those that do not explicitly inherit from any other classes."
  660.   (br-get-top-class-list "parents"))
  661.  
  662. (defun br-get-lib-top-classes ()
  663.   "Returns lexicographically ordered list of top-level Library classes.
  664. Those that do not explicitly inherit from any other classes."
  665.   (br-get-top-class-list "lib-parents"))
  666.  
  667. (defun br-get-sys-top-classes ()
  668.   "Returns lexicographically ordered list of top-level System classes.
  669. Those that do not explicitly inherit from any other classes."
  670.   (br-get-top-class-list "sys-parents"))
  671.  
  672. (defun br-has-children-p (class-name)
  673.   "Return non-nil iff CLASS-NAME has at least one child.
  674. That is a class that directly inherits from CLASS-NAME."
  675.   (setq class-name (and class-name (br-set-case class-name)))
  676.   (hash-get class-name (br-get-children-htable)))
  677.  
  678. (defun br-has-parents-p (class-name)
  679.   "Return non-nil iff CLASS-NAME has at least one parent.
  680. That is a class which is a direct ancestor of CLASS-NAME."
  681.   (setq class-name (and class-name (br-set-case class-name)))
  682.   (hash-get class-name (br-get-parents-htable)))
  683.  
  684. (defun br-get-process-group (group max)
  685.   "Return list of all active processes in GROUP (a string).
  686. MAX is max number of processes to check for."
  687.   (let ((i 0)
  688.     (proc-list))
  689.     (while (<= i max)
  690.       (setq i (1+ i)
  691.         proc-list (cons (get-process (concat group (int-to-string i)))
  692.                 proc-list)))
  693.     (delq nil proc-list)))
  694.  
  695.  
  696. (defun br-kill-process-group (group max group-descrip)
  697.   "Optionally question user, then kill all subprocesses in named GROUP.
  698. Processes are numbered one to MAX, some of which may have been killed already.
  699. User is prompted with a string containing GROUP-DESCRIP, only if non-nil.
  700. Return list of processes killed."
  701.   (let ((proc-list (br-get-process-group group max)))
  702.     (if proc-list
  703.     (if (or (null group-descrip)
  704.         (y-or-n-p (concat "Terminate all " group-descrip "? ")))
  705.         (prog1 (mapcar 'delete-process proc-list)
  706.           (message ""))))))
  707.  
  708. (defun br-real-add-class (lib-table-p class-name class-path &optional replace)
  709.   "Add or replace class in current Environment.
  710. If LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
  711. System Environment.  Add class CLASS-NAME located in CLASS-PATH to
  712. Environment.  If CLASS-PATH is nil, use current buffer file as CLASS-PATH.
  713. Optional REPLACE non-nil means replace already existing class.  Does not
  714. update children lookup table."
  715.   (or class-path (setq class-path buffer-file-name))
  716.   (let ((par-list)
  717.     (paths-key class-path)
  718.     (func)
  719.     (class class-name))
  720.     (if replace
  721.     (setq func 'hash-replace
  722.           class-name (br-first-match
  723.               (concat "^" (regexp-quote class-name) "$")
  724.               (hash-get paths-key
  725.                     (if lib-table-p 
  726.                     (br-get-htable "lib-paths")
  727.                       (br-get-htable "sys-paths"))))
  728.           par-list (br-get-parents-from-source class-path class-name))
  729.       (setq func 'hash-add))
  730.     ;; Signal error if class-name is invalid.
  731.     (if (null class-name)
  732.     (if replace
  733.         (error "(br-real-add-class): '%s' not found in %s classes, so cannot replace it."
  734.            class (if lib-table-p "Library" "System"))
  735.         (error
  736.          "(br-real-add-class): Attempt to add null class to %s classes."
  737.          (if lib-table-p "Library" "System"))))
  738.     ;;
  739.     (mapcar
  740.       (function
  741.     (lambda (type)
  742.      (let ((par-htable (br-get-htable (concat type "parents")))
  743.            (path-htable (br-get-htable (concat type "paths"))))
  744.        (funcall func par-list class-name par-htable)
  745.        (br-add-to-paths-htable class-name paths-key path-htable))))
  746.       (list (if lib-table-p "lib-" "sys-") ""))))
  747.  
  748. (defun br-real-delete-class (class-name)
  749.   "Delete class CLASS-NAME from current Environment.
  750. No error occurs if the class is undefined in the Environment."
  751.   (require 'set)
  752.   (let ((paths-key (br-class-path class-name))
  753.     htable)
  754.     (setq class-name
  755.       (br-first-match (concat "^" class-name "$")
  756.               (hash-get paths-key (br-get-paths-htable))))
  757.     (if class-name
  758.     (progn (mapcar
  759.          (function
  760.            (lambda (type)
  761.             (hash-delete class-name 
  762.                  (br-get-htable (concat type "parents")))
  763.             (setq htable (br-get-htable (concat type "paths")))
  764.             (if (hash-key-p paths-key htable)
  765.             (hash-replace
  766.              (set:remove
  767.               class-name
  768.               (hash-get paths-key htable))
  769.              paths-key htable))))
  770.          '("lib-" "sys-" ""))
  771.            (hash-delete class-name (br-get-children-htable))))))
  772.  
  773. (defun br-real-build-children-htable ()
  774.   "Build and return Environment parent to child lookup table."
  775.   (let* ((par-ht (br-get-parents-htable))
  776.      (htable (hash-make (hash-size par-ht)))
  777.      (child))
  778.     (hash-map
  779.       (function
  780.     (lambda (par-child-cns)
  781.       (setq child (cdr par-child-cns))
  782.       (mapcar
  783.         (function
  784.           (lambda (parent)
  785.         (hash-add
  786.           (cons child (hash-get parent htable))
  787.           parent htable)))
  788.         (car par-child-cns))))
  789.       par-ht)
  790.     (hash-map (function
  791.         (lambda (children-parent-cns)
  792.           (hash-replace (sort (car children-parent-cns) 'string-lessp)
  793.                 (cdr children-parent-cns) htable)))
  794.           htable)
  795.     htable))
  796.  
  797. (defun br-real-get-children (class-name)
  798.   "Return list of child classes of CLASS-NAME listed in Environment parents htable."
  799.   (delq nil (hash-map
  800.           (function
  801.         (lambda (cns)
  802.           (if (and (consp cns)
  803.                (br-member class-name (car cns)))
  804.               (cdr cns))))
  805.           (br-get-parents-htable))))
  806.  
  807. (defun br-real-build-alists (search-dirs)
  808.   "Use SEARCH-DIRS to build 'br-paths-alist' and 'br-parents-alist'."
  809.   (setq br-paths-alist nil br-parents-alist nil)
  810.   (br-feature-tags-init)
  811.   (br-real-build-al search-dirs)
  812.   (setq br-paths-alist br-paths-alist)
  813.   (br-feature-tags-save)
  814.   br-paths-alist)
  815.  
  816. (defvar br-paths-alist nil)
  817. (defvar br-parents-alist nil)
  818.  
  819. (defun br-skip-dir-p (dir-name)
  820.   "Returns non-nil iff DIR-NAME is matched by a member of 'br-skip-dir-regexps'."
  821.   (delq nil
  822.     (mapcar (function
  823.           (lambda (dir-regexp)
  824.             (string-match dir-regexp
  825.                   (file-name-nondirectory
  826.                     (directory-file-name dir-name)))))
  827.         br-skip-dir-regexps)))
  828.  
  829. ;;; If abbreviate-file-name is not defined, just make it return the same
  830. ;;; string.
  831. (or (fboundp 'abbreviate-file-name)
  832.     (fset 'abbreviate-file-name 'identity))
  833.  
  834. (defun br-real-build-al (search-dirs)
  835.   "Descend SEARCH-DIRS and build 'br-paths-alist' and 'br-parents-alist'.
  836. Does not initialize 'br-paths-alist' or 'br-parents-alist' to nil."
  837.   (let ((inhibit-local-variables nil)
  838.     (enable-local-variables t)
  839.     (files)
  840.     ;; These are used in the 'br-search-directory' function.
  841.     classes parents paths-parents-cons)
  842.     (mapcar 
  843.       (function
  844.     (lambda (dir)
  845.       (if (or (null dir) (equal dir "")
  846.           (progn (setq dir (file-name-as-directory dir))
  847.              (br-skip-dir-p dir)))
  848.           nil
  849.         (setq files (if (and (file-directory-p dir)
  850.                   (file-readable-p dir))
  851.                 (directory-files dir t br-file-dir-regexp)))
  852.         ;; Extract all class/parent names in all source files in a
  853.         ;; particular directory.
  854.         (if files
  855.         (progn (message "Scanning %s in %s ..."
  856.                 (file-name-nondirectory
  857.                  (directory-file-name dir))
  858.                 (abbreviate-file-name
  859.                  (or (file-name-directory
  860.                       (directory-file-name dir))
  861.                      "")))
  862.                (br-search-directory dir files)
  863.                ;; Call same function on all the directories below
  864.                ;; this one.
  865.                (br-real-build-al
  866.             (mapcar (function (lambda (f)
  867.                         (if (file-directory-p f) f)))
  868.                 files)))))))
  869.       search-dirs)))
  870.  
  871. (defun br-search-directory (dir files)
  872.   (mapcar
  873.     (function
  874.       (lambda (f)
  875.     (setq paths-parents-cons
  876.           (let ((br-view-file-function 'br-insert-file-contents))
  877.         (message "Scanning %s in %s ..."
  878.              (file-name-nondirectory f)
  879.              (abbreviate-file-name
  880.               (or (file-name-directory f) default-directory)))
  881.         (br-get-classes-from-source f nil t))
  882.           classes (car paths-parents-cons)
  883.           parents (cdr paths-parents-cons)
  884.           br-paths-alist (if classes
  885.                  (cons (cons (sort classes 'string-lessp) f)
  886.                        br-paths-alist)
  887.                    br-paths-alist)
  888.           br-parents-alist (if parents
  889.                    (append br-parents-alist
  890.                        parents)
  891.                  br-parents-alist))))
  892.     ;; List of files potentially containing classes.
  893.     (delq nil
  894.       (mapcar
  895.         (function
  896.           (lambda (f)
  897.         (and (string-match br-src-file-regexp f)
  898.              (not (file-directory-p f))
  899.              f)))
  900.         files))))
  901.  
  902. (defun br-real-build-parents-alist (paths-htable)
  903.   "Build and return 'br-parents-alist' of (parent-list . class) elements built from PATHS-HTABLE.
  904. Initializes 'br-parents-alist' to nil."
  905.   (let ((inhibit-local-variables nil)
  906.     (enable-local-variables t))
  907.     (setq br-parents-alist nil)
  908.     (mapcar
  909.       (function
  910.     (lambda (cl-dir-list)
  911.       (mapcar (function
  912.             (lambda (class-dir-cons)
  913.               (let ((dir (cdr class-dir-cons)))
  914.             (mapcar
  915.               (function
  916.                 (lambda (class-name)
  917.                   (setq br-parents-alist
  918.                     (cons (cons (br-get-parents-from-source
  919.                          dir class-name)
  920.                         class-name)
  921.                       br-parents-alist))))
  922.               (car class-dir-cons)))))
  923.           cl-dir-list)))
  924.       paths-htable)
  925.     br-parents-alist))
  926.  
  927. (defun br-set-lang-env (func sym-list val)
  928.   "Use FUNC to set each element in SYM-LIST.
  929. If VAL is non-nil, set 'br' element to value of current OO-Browser language
  930. element with the same name, otherwise set to symbol."
  931.   (let ((br) (lang))
  932.     (mapcar (function
  933.          (lambda (nm)
  934.            (setq br   (intern (concat "br-" nm))
  935.              lang (intern-soft (concat br-lang-prefix nm)))
  936.            (funcall func br (if val
  937.                     (symbol-value lang)
  938.                   (or lang 'br-undefined-function)))))
  939.         sym-list)))
  940.  
  941. (defun br-undefined-function (&rest ignore)
  942.   (interactive)
  943.   (error "(OO-Browser): That command is not supported for this language."))
  944.  
  945. (defun br-setup-functions ()
  946.   "Initialize appropriate function pointers for the current browser language."
  947.   (br-set-lang-env 'fset
  948.            '("class-definition-regexp" "class-list-filter"
  949.              "get-classes-from-source" "get-parents-from-source"
  950.              "insert-class-info" "set-case" "set-case-type"
  951.              "to-class-end" "to-comments-begin" "to-definition"
  952.              "select-path"
  953.  
  954.              "feature-implementors" "feature-locate-p"
  955.              "feature-name-to-regexp" "feature-signature-to-name"
  956.              "feature-signature-to-regexp" "feature-tag-class"
  957.              "feature-tree-command-p"
  958.              "list-categories" "list-features" "list-protocols"
  959.              "view-friend" "view-protocol")
  960.            nil))
  961.  
  962. (defun br-setup-constants ()
  963.   "Initialize appropriate constant values for the current browser language."
  964.   ;; Clear language-dependent hooks.
  965.   (setq br-after-build-lib-hook nil
  966.     br-after-build-sys-hook nil)
  967.   ;; Set language-specific constants.
  968.   (br-set-lang-env 'set '("class-def-regexp" "env-file"
  969.               "file-dir-regexp" "identifier" "identifier-chars"
  970.               "src-file-regexp" "narrow-view-to-class"
  971.               "type-tag-separator")
  972.            t))
  973.  
  974. ;;; ************************************************************************
  975. ;;; Private variables
  976. ;;; ************************************************************************
  977.  
  978. (defvar br-lib-search-dirs nil
  979.   "List of directories below which library dirs and source files are found.
  980. A library is a stable group of classes.  Value is language-specific.")
  981. (defvar br-sys-search-dirs nil
  982.   "List of directories below which system dirs and source files are found.
  983. A system is a group of classes that are likely to change.  Value is
  984. language-specific.")
  985.  
  986. (defvar br-lib-prev-search-dirs nil
  987.   "Used to check if 'br-lib-paths-htable' must be regenerated.
  988. Value is language-specific.")
  989. (defvar br-sys-prev-search-dirs nil
  990.   "Used to check if 'br-sys-paths-htable' must be regenerated.
  991. Value is language-specific.")
  992.  
  993. (defun br-find-file (filename &optional other-win read-only)
  994.   "Edit file FILENAME.
  995. Switch to a buffer visiting file FILENAME, creating one if none
  996. already exists.  Optional OTHER-WIN means show in other window.
  997. Optional READ-ONLY means make buffer read-only."
  998.   (interactive "FFind file: ")
  999.   (funcall (if other-win 'switch-to-buffer-other-window 'switch-to-buffer)
  1000.        (find-file-noselect filename))
  1001.   (and read-only (setq buffer-read-only t)))
  1002.  
  1003. (defun br-find-file-read-only (filename &optional other-win)
  1004.   "Display file FILENAME read-only.
  1005. Switch to a buffer visiting file FILENAME, creating one if none
  1006. already exists.  Optional OTHER-WIN means show in other window."
  1007.   (interactive "FFind file read-only: ")
  1008.   (br-find-file filename other-win t))
  1009.  
  1010. (defvar br-edit-file-function 'br-find-file
  1011.   "*Function to call to edit a class file within the browser.")
  1012. (defvar br-view-file-function
  1013.   (if (eq br-edit-file-function 'br-find-file)
  1014.       'br-find-file-read-only
  1015.     br-edit-file-function)
  1016.   "*Function to call to view a class file within the browser.")
  1017.  
  1018. (defvar br-find-file-noselect-function 'find-file-noselect
  1019.   "Function to call to load a browser file but not select it.
  1020. The function must return the buffer containing the file's contents.")
  1021.  
  1022. (defvar *br-tmp-buffer* "*oobr-tmp*"
  1023.   "Name of temporary buffer used by the OO-Browser for parsing source files.")
  1024.  
  1025. (defun br-insert-file-contents (filename)
  1026.   "Insert FILENAME contents into a temporary buffer and select buffer.
  1027. Does not run any find-file hooks.  Marks buffer read-only to prevent
  1028. any accidental editing.
  1029.  
  1030. Set 'br-view-file-function' to this function when parsing OO-Browser source
  1031. files for fast loading of many files."
  1032.   (let ((buf (get-buffer-create *br-tmp-buffer*)))
  1033.     (switch-to-buffer buf)
  1034.     (buffer-disable-undo buf)
  1035.     (setq buffer-read-only nil)
  1036.     (erase-buffer)
  1037.     (insert-file-contents filename t)))
  1038.  
  1039. (defvar br-lang-prefix nil
  1040.  "Prefix string that starts language-specific symbol names.")
  1041.  
  1042. (defvar br-children-htable nil
  1043.   "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
  1044. Used to traverse class inheritance graph.  'br-build-children-htable' builds
  1045. this list.  Value is language-specific.")
  1046. (defvar br-parents-htable nil
  1047.   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
  1048. Used to traverse class inheritance graph.  'br-build-parents-htable' builds
  1049. this list.  Value is language-specific.")
  1050. (defvar br-paths-htable nil
  1051.   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
  1052. DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
  1053. 'br-build-paths-htable' builds this list.  Value is language-specific.")
  1054.  
  1055. (defvar br-lib-parents-htable nil
  1056.   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
  1057. Only classes from stable software libraries are used to build the list.
  1058. Value is language-specific.")
  1059. (defvar br-lib-paths-htable nil
  1060.   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
  1061. DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
  1062. Only classes from stable software libraries are used to build the list.
  1063. Value is language-specific.")
  1064.  
  1065. (defvar br-sys-parents-htable nil
  1066.   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
  1067. Only classes from systems that are likely to change are used to build the
  1068. list.  Value is language-specific.")
  1069. (defvar br-sys-paths-htable nil
  1070.   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
  1071. DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
  1072. Only classes from systems that are likely to change are used to build the
  1073. list.  Value is language-specific.")
  1074.  
  1075. (defvar br-file-dir-regexp nil
  1076.   "Regexp that ignores extraneous, non-source files and directories.")
  1077.  
  1078. (defvar br-src-file-regexp nil
  1079.   "Regular expression matching a unique part of source file names and no others.")
  1080.  
  1081. (defvar br-narrow-view-to-class nil
  1082.  "Non-nil means narrow buffer to just the matching class definition when displayed.
  1083. Don't set this, use the language specific variable instead.")
  1084.  
  1085. (provide 'br-lib)
  1086.